;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
#||
			RESTRICTED RIGHTS LEGEND
				    
 Use, duplication, or disclosure by the Government is subject to
 restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
 Technical Data and Computer Software Clause at 52.227-7013 of the DOD
 FAR Supplement.
				    
				TSP (The Software Partnership)
				P.O. Box 991
				Melrose, MA 02176
				    
      Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
||#

(in-package :ooga)

;This file contains utilities for the genetic algorithm system.

;**************************************************

;	ROUTINES THAT GET ITEMS FROM LISTS BY THEIR ASSOCIATED WEIGHTS


(defun MAKE-WEIGHTED-LIST (elements weights)
  "Produce a list of outputs based on the input weights.
Elements are returned in order of decreasing weights."
  (let ((element-weight-pairs (mapcar #'cons elements weights)))
    (mapcar #'car (sort element-weight-pairs #'> :key #'cdr))))


(defun GET-ASSOCIATED-TOTAL-LIST-ELEMENT (element-list weight-list total)
  "Get the element and its place whose weight corresponds to the running total"
  (do ((elements element-list (cdr elements))
       (weights weight-list (cdr weights))
       (n 0 (1+ n)))
      ((null elements))
    (if (>= (car weights) total)
	(return (values (car elements) n))
	(setf total (- total (car weights))))))


(defun GET-ASSOCIATED-LINKED-LIST-ELEMENT (first-element weight-list total)
  "Get the element and its place whose weight corresponds to the running total"
  (loop for element = first-element then (successor element)
	for weight in weight-list
	for running-total = (car weight-list) then (+ weight running-total)
	for n from 0
	do (if (>= running-total total)
	       (return (values element n)))))


(defun GET-ASSOCIATED-RUNNING-TOTAL-ELEMENT (element-list weight-list total)
  "Get the element and its place whose weight is less than the precompiled running total"
  (do ((elements element-list (cdr elements))
       (weights weight-list (cdr weights))
       (n 0 (1+ n)))
      ((null elements))
    (if (>= (car weights) total)
	(return (values (car elements) n)))))



;**************************************************

;	RANDOM NUMBER GENERATOR ROUTINES

;;; We want to provide a general portable interface for generating random numbers.
;;; Ideally, users should be given the option of whether different runs
;;; of these random numbers should have identical or guaranteed
;;; different random sequences.  (I.E.  You may want to be able to
;;; reproduce previous results with the same random numbers).
;;; If reproducibility is important, than so is portability of a random
;;; number generator (which we will hopefully provide).


#+ignore  ;; We no longer shadow Random because of the problems it was causing in some implementations
(defun RANDOM (high &optional state)
  "The random number function we call in all places.  Redefine this if
you want some special behavior of the random number generator."
  (if state 
      (lisp:random high state)
      (lisp:random high)
      ))

;;;
;;; The following normal generators may be useful for some applications...
;;; 

;;; The function Normal-Random-Number comes with the following copyright:
;;; ------------------------------------------------------------
;;;  (c) Copyright Gerald Roylance 1983, 1984, 1987
;;;      All Rights Reserved.
;;;  This file may be distributed noncommercially provided
;;;  that this notice is not removed.
;;; ------------------------------------------------------------

;;;; Normal Random Number

;;; -- Ratio of Uniform Deviates Method

;;;   f(x) = (exp (-x*x/2))
;;;           the / (sqrt (* 2 pi))  doesn't matter
;;;   mean = 0
;;;   vari = 1
;;; u-bound : 0 <= u <= 1
;;; v-bound :      u <= sqrt(exp(-(v/u)**2/2)
;;;                   = exp(-v**2 / (4 u**2))
;;;         : log(u) <= -v**2 / (4 u**2)
;;;         : 4 u**2 log(u) <= -v**2
;;;         : v**2   <= -4 u**2 log(u)
;;;    rhs is max when d(rhs)/du = 0
;;;        -4 (2u log(u) + u) = 0
;;;        -4u (2 log(u) + 1) = 0
;;;          u = {0, exp(-0.5)}
;;;  therefore the v-bound is
;;;         : v**2   <= -4 u**2 log(u) = -4 exp(-1) (-0.5)
;;;                                    =  2 exp(-1)
;;;    -sqrt(2)exp(-0.5) <= v <= +sqrt(2)exp(-0.5)
;;;
;;; P{acceptance} = 0.73057

(defun NORMAL-RANDOM-NUMBER ()
  "Returns a normally distributed deviate with 0 mean and unit variance."
  (flet ((uniform-random-number () (random 1.0)))
    (do ((u 0.0)
	 (v 0.0))
	((progn
	   (setq u (uniform-random-number)	; U is bounded (0 1)
		 v (* 2.0 (sqrt 2.0) (exp -0.5)	; V is bounded (-MAX MAX)
		      (- (uniform-random-number) 0.5)))
	   (<= (* v v) (* -4.0 u u (log u))))	; < should be <=
	 (/ v u))
      (declare (float u v)))))

;;; The following is translated from Numerical Recipes
;;; It is about twice as fast, mostly because it only has to do work every other call.
(let (gset
      (iset nil))
  (defun GASDEV ()
    (cond ((null iset)
	   (loop for v1 = (1- (* 2 (random 1.0)))
		 and v2 = (1- (* 2 (random 1.0)))
		 for r = (+ (* v1 v1) (* v2 v2))
		 until (< r 1)
		 finally (let ((fac (sqrt (/ (* -2.0 (log r)) r))))
			   (setf gset (* v1 fac)
				 iset t)
			   (return (* v2 fac)))))
	  (t (setf iset nil)
	     (values gset)))))



;**************************************************

;	UTILITY ROUTINES


(defun ROUND-TO (number place)
  "Round to the place after the decimal.  Place should
   be a power of 10.  Ex:  (round-to 5.45678 1000) ==> 5.457"
  (/ (round (* number place)) (float place)))


(defun CREATE-RANDOM-BIT-STRING (length)
  (loop for x below length
	collect (random 2)))


(defun EVEN-MULTIPLE (number base)
  "Is number even multiple of base?"
  (= number (* base (floor (/ number base)))))


(defun NEXT-EVEN-INTERVAL (current-number interval)
  "Return next multiple of interval.  
   Assumption is that both current-number and interval are integers."
  (+ (* interval (floor (/ current-number interval)))
     interval))


(defun CONVERT-BIT-STRING-TO-INTEGER (bit-string)
  "Convert the bit string to an integer using powers of 2"
  (loop for bit in (reverse (copy-list bit-string))
	for 2-power = 1 then (+ 2-power 2-power)
	summing (if (= bit 1) 2-power 0)))


(defun BIGGEST-2-DIVISOR (integer)
  "Find the larger power of 2 in the integer"
  (loop for 2-power = 1 then (+ 2-power 2-power)
	until (> 2-power integer)
	finally (return (/ 2-power 2))))


(defun CONVERT-INTEGER-TO-BIT-STRING (integer)
  "Convert the integer to a bit string"
  (if (< integer 1) '(0)
  (loop with number = integer
	for 2-power = (biggest-2-divisor integer)
	    then (/ 2-power 2)
	until (< 2-power 1)
	collect (if (< number 2-power) 0
		    (and (setf number (- number 2-power)) 1))
	into bits
	finally (return bits))))


(defun ONE-POINT-CROSSOVER (list1 list2)
  "Cross the two lists at a randomly selected point."
  (if (< (length list1) 2)
      (values list1 list2)
      (let ((crossover-point (1+ (random (1- (length list1))))))
	(list (append (firstn crossover-point list1)
		      (nthcdr crossover-point list2))
	      (append (firstn crossover-point list2)
		      (nthcdr crossover-point list1))))))

(defun TWO-POINT-CROSSOVER (list1 list2)
  "Cross the two lists at 2 randomly selected points."
  (if (< (length list1) 2)
      (values list1 list2)
      (let ((first-crossover-chromosomes
	    (one-point-crossover list1 list2)))
	(one-point-crossover
	  (car first-crossover-chromosomes)
	  (cadr first-crossover-chromosomes)))))


(defun MUTATE-BITS (mutation-rate bit-string)
  "Mutate any bits in the bit string that pass the probability test"
  (loop for bit in bit-string
	collect (if (probability-test mutation-rate) (random 2) bit)))


(defun TRANSFER-LIST-STRUCTURE (list1 list2)
  "Put list1's structure in list2.
   Both items should be lists.  NIL will not work in list2."
  (rplaca list2 (car list1))
  (rplacd list2 (copy-tree (cdr list1))))


(defun PROBABILITY-TEST (prob)
  "Return t with probability prob, compared to 1.0."
  (<= (random 1.0) prob))


(defun RANDOM-INTEGER (integer-1 integer-2)
  "Return a random integer between (and including) the two given ones."
  (+ (min integer-1 integer-2)
     (random (1+ (abs (- integer-1 integer-2))))))


(defun RANDOM-MEMBER (list)
  "Return a random member of the list.  List can't be null."
  (nth (random (length list)) list))

(defun random-boolean ()
  "Return T or NIL, with equal probability."
  (= 0 (random 2)))

(defun AVERAGE (list)
  "Return floating point average of list of numbers"
  (/ (apply '+ list) (float (length list))))


(defun INTEGER-AVERAGE (int1 int2)
  "Average two integers, with random rounding."
  (values (funcall (nth (random 2) '(floor ceiling))
		   (+ int1 int2)
		   2)))


(defun AVERAGE-FIRST-N-VALUES (n lists)
  "Average the values in the first n lists."
  (let* ((length (min n (length lists)))
	 (totals (apply 'mapcar (cons '+ (firstn length lists)))))
    (loop for total in totals
	  collect (/ total (float length)))))


(defun AVERAGE-WEIGHTS-AT-STAGE (stage history)
  "Determine the average weights at the requested stage in the history"
  (let* ((time (car stage))
	(index  (loop for item in (car history)
		      for n from 0
		      when (equal (car item) time)
		      do (return n)))
	(data (loop for item in history
		    collect (cadr (nth index item)))))
    (list time (parallel-average data))))


(defun PARALLEL-AVERAGE (lists)
  "Average the parallel fields of the lists"
  (loop for n from 0 to (1- (length (car lists)))
	collect (average (loop for list in lists collect (nth n list)))))


(defun MAKE-NUMBER-LIST (start end &optional (inc 1))
  "Make a list of numbers from start to end"
  (do ((n start (+ n inc))
       (number-list nil (cons n number-list)))
      ((> n end) (reverse number-list))))


(defun CREEP-VALUE (creep-specs old-value)
  "Move old-value (a number) up or down by a random amount.  Uniform dist."
  (let ((new-number
	  (if (= (random 2) 0)
	      (+ old-value (random (caar creep-specs)))
	      (- old-value (random (caar creep-specs))))))
    (if (cadar creep-specs) (round new-number) new-number)))


(defun MAKE-RANDOM-VALUE (v-min v-max &optional (integer-value? nil))
  "Produce a value between v-min and v-max.  Fix if integer is desired."
  (let* ((interval (float (- v-max v-min)))
	 (new-number (- v-max (random interval))))
    (if integer-value? (round new-number) new-number)))


;Reproduction of functionality of Zetalisp function, I hope.
(defun FIRSTN (n list)
  #-explorer
  (butlast list (- (length list) n))
  #+explorer
  (ticl:firstn n list))



;Functionality of Zetalisp function for one-dimensional arrays.
#-(or explorer genera)
(defun FILLARRAY (array list)
  "Put the list items in the array."
  (do ((n 0 (1+ n))
       (array-length (array-dimension array 0))
       (items list (cdr items)))
      ((= n array-length))
    (setf (aref array n) (car items))))

#+(or explorer genera)
(import 'zl:fillarray)


(defun LISTARRAY (array)
  "One-dimensional version of zl:listarray"
  (do ((n 0 (+ 1 n))
       (list))
      ((= n (array-dimension array 0)) (reverse list))
    (setf list (cons (aref array n) list))))


(defun SCRAMBLE-SUBLIST (list cut-point1 cut-point2)
  "Scramble the sublist of the list between the two cut points and return the result.
Assumption is that the cut points are in increasing numerical order."
  (assert (<= cut-point1 cut-point2))
  (append (firstn cut-point1 list)
	  (nscramble (copy-list (firstn (- cut-point2 cut-point1)
				       (nthcdr cut-point1 list))))
	  (nthcdr cut-point2 list)))


(defun GET-TWO-CUT-POINTS (limit)
  "Get two cut points in the range from 0 to 1 below limit.  Scramble region
   is truncated at the beginning and end of the range."
  (if (< limit 2)
      (values 0 1)
      (let* ((value1 (random limit))
	     (amount (1+ (random limit)))
	     (direction (random 2)))
	(if (= direction 0)
	    (values (max 0 (- value1 amount)) value1)
	    (values value1 (min (1- limit) (+ value1 amount)))))))


(defun NSCRAMBLE (scramble-list)
  "Destructive scramble of a list.  Be sure to setq the result."
  (flet ((roll (list index) (if (plusp index)
				(let* ((t1 (nthcdr (1- index) list))
				       (t2 (cdr t1)))
				  (rplacd t1 (cdr t2))
				  (rplacd t2 list))
				list)))
    (when scramble-list
      (let* ((list-length (length scramble-list))
	     (item-position (random list-length)))
	(setq scramble-list (roll scramble-list item-position))
	(loop for n from (1- list-length) above 1
	      for new-list on scramble-list
	      do (setq item-position (random n))
	      (rplacd new-list (roll (cdr new-list) item-position))))
      scramble-list)))


(defun GET-SCRAMBLE-SET (parent1 parent2 template)
  "Get the ordering of items not associated with 1 on parent1 according to parent2.
Template is a list of bits (0s and 1s)."
  (order-by-reference (loop for bit in template
			    for item in parent1
			    when (= bit 0)
			      collect item)
		      parent2))


(defun ORDER-BY-REFERENCE (list reference-list)
  "Return the items in the list in the order they occur in in the reference list"
  (loop for item in reference-list
	when (member item list)
	collect item))



(defun TEMPLATE-ASSEMBLE (template list replacements)
  "Return a list consisting of elements of LIST when template value is 1 and
of elements of REPLACEMENTS when template value is 0."
  (mapcar #'(lambda (bit x)
	      (if (= bit 0)
		  (pop replacements)
		  x))
	  template list))


(defun INTERPOLATE-FROM-SPEC (first-y last-y last-x current-x)
  "Interpolate based on current x value."
  (if (listp first-y)
      (do ((first-y-list first-y (cdr first-y-list))
	   (last-y-list last-y (cdr last-y-list))
	   (interpolated-values nil))
	  ((null first-y-list) (nreverse interpolated-values))
	(setf interpolated-values
	      (cons (interpolate 0 (car first-y-list)
				 last-x (car last-y-list) current-x)
		    interpolated-values)))
      (interpolate 0 first-y
		   last-x last-y current-x)))


(defun INTERPOLATE (x1 y1 x2 y2 x3)
  "Perform linear interpolation to point 3 from points 1 and 2.
  If x1 = x2, y1 is the value returned."

  (if (= x1 x2) y1
      (let*  ((dx (- x2 x1))
	      (dy (- y2 y1))
	      (slope (/ dy (float dx))))
	(+ y1 (* slope (- x3 x1))))))


(defun NORMALIZE (list average-value &optional (fields (length list)))
  "Multiply all fields in the list by a factor so that their average
   is the desired average value."
  (let* ((total (apply '+ list))
	 (factor (if (not (= total 0))
		     (/ (* (float fields) average-value) total)
		     1.0)))
    (mapcar #'(lambda (field)
		(round (* factor field)))
	    list)))


(defun NORMALIZE-TOTAL (list total-value)
  "Normalize the list so it totals total-value.  Avoid use if there are negative
values in the list."
  (let* ((total (apply '+ list))
	 (factor (if (< (abs total) .000000000000000001)
		     1 (/ (float total-value) total))))
    (mapcar #'(lambda (x)
		(* factor x))
	    list)))



;;; DOUBLY LINKED LISTS

;;; A double-linked-list is a list of doubly-linked elements.  The list
;;; maintains pointers to the first and last members.

(defclass DOUBLY-LINKED-LIST
	  ()
  ((FIRST-MEMBER :initarg :first-member :initform nil :accessor FIRST-MEMBER)
   (LAST-MEMBER :initarg :last-member :initform nil :accessor LAST-MEMBER)))


(defclass DOUBLY-LINKED-LIST-ELEMENT
	  ()
  ((PREDECESSOR :initarg :predecessor :initform nil :accessor PREDECESSOR)
   (SUCCESSOR :initarg :successor :initform nil :accessor SUCCESSOR))
  )

(defmethod MAP-OVER-ELEMENTS (function (doubly-linked-list doubly-linked-list))
  (loop for element = (first-member doubly-linked-list) then (successor element)
	until (null element)
	collect (funcall function element)))


(defmacro DO-ELEMENTS ((var doubly-linked-list) &body body)
  `(loop for ,var = (first-member ,doubly-linked-list) then (successor ,var)
	 until (null ,var)
	 do . ,body))


(defmethod LINK-MEMBERS ((doubly-linked-list doubly-linked-list) members)
  "Link the members (list of members).  Assumption is that they are in desired order."
  (link doubly-linked-list nil (car members) (cadr members))
  (do ((list members (cdr list)))
      ((null list))
    (link doubly-linked-list (car list) (cadr list) (caddr list))))


(defmethod LINK ((doubly-linked-list doubly-linked-list)
		 first-member second-member third-member)
  "Link the three members in a doubly linked list"
  (if first-member
      (setf (successor first-member) second-member))
  (when second-member
    (setf (successor second-member) third-member
	  (predecessor second-member) first-member))
  (if third-member
      (setf (predecessor third-member) second-member)))




;******************************************************

;	PERFORMANCE COLLECTION ROUTINES


(defun AVERAGE-CADRS (list)
  "Average the cadrs of parallel conses across the lists in the list"
  (let* ((length (length list))
	 (totals (sum-cadrs list)))
    (loop for x in totals
	  collect (list (car x) (/ (cadr x) (float length))))))


(defun SUM-CADRS (list)
  "Sum the cadrs of parallel conses across the lists in the list"
  (loop for sublist in (cdr list)
	with sum = (loop for item in (car list)
			 collect (list (car item) (cadr item)))
	do (loop for item in sublist
		 for total in sum
		 do (setf (cadr total) (+ (cadr total) (cadr item))))
	finally (return sum)))


(defun EVALUATION-AT-TIME (time list)
  "Return the evaluation at the time from an incremental performance list.
   Assumption is that list is in reverse temporal order."
  (loop for pair in list
	when (>= time (car pair))
	return (cadr pair)
	finally (format t "~%~%NO VALUE FOR TIME ~a IN LIST ~a"
			time list)))


(defun COUNT-DECIMAL-NINES (number)
  "Count the nines after the decimal.  Used in evaluations of F6 functions
in the tutorial."
  (loop with count = 0
	for digit in
	    (cdr (member #\. (coerce (format nil "~a" number) 'list)))
	while  (eq digit #\9)
	do (incf count)
	finally (return count)))


(defmethod NINE-COUNT (population-member)
  "Count the decimal nines in the member's evaluation."
  (count-decimal-nines (evaluation population-member)))


;;;For REAL CLOS systems, this is a normal DEFMETHOD with APPEND combination.
;;;For less-than-real CLOS implementations (eg. old PCL), use AROUND methods to get
;;;the job done...

(defmacro def-append-method (name lambda-list &body body)
  (unless (consp lambda-list)
    (error "Looks like you have a bad lambda list for DEF-APPEND-METHOD!"))
  #-:old-pcl
  `(defmethod ,name append ,lambda-list . ,body)
  #+:old-pcl
  `(defmethod ,name :around ,lambda-list
	      (append (progn . ,body)
		      (call-next-method))))

;;;For some reason, the Explorer didn't have APPEND method combination.
;;;Define it for them.
;;;The Explorer may define it in the future.  In this case, just comment the
;;;following out...
#+ti
(define-method-combination append
  :operator append
  :identity-with-one-argument t)

;;; PCL Workarounds...
;;; Defgeneric isn't fully supported by PCL, so make it a noop
#+:pcl
(defmacro DEFGENERIC (&rest ignore) nil)
